#   LibAut
#       helper functions and constants
#   Juraj Medzihorsky
#   2021-08-10

#   golden ration function
gr <- function(x)  ((1+sqrt(5))/2)^x


#   column names in a data.frame
dname <- function(x, md=d) names(md)[grep(x,names(md))]


#   color palette from https://www.nature.com/articles/nmeth.1618
naturecolor <-
    function(nm, a=255)
    {
        if ((a<0)|(a>255)) {
            stop('alpha must be in [0,255]\n')
        }
        kol <- c(rgb(  86, 180, 233, a, max=255),  #   blue
                 rgb( 230, 159,   0, a, max=255),  #   orange
                 rgb(   0, 158, 115, a, max=255),  #   green
                 rgb(   0,   0,   0, a, max=255),  #   black
                 rgb( 240, 228,  66, a, max=255),  #   yellow
                 rgb(   0, 114, 178, a, max=255),  #   dark blue
                 rgb( 213,  94,   0, a, max=255),  #   red
                 rgb( 204, 121, 167, a, max=255))  #   purple
        names(kol) <- c('blue', 'orange', 'green', 'black',
                        'yellow', 'dark blue', 'red', 'purple')
        if (!(nm%in%names(kol))) {
            stop('invalid color name\n')    
        }
        return(kol[nm])
    }
natcol <- naturecolor


#   mix color with white
mixw <-
    function(x, w)
    {
        r <- as.vector(col2rgb(x))
        n <- r*(1-w) + rep(255, 3)*w
        n <- pmin(n, rep(255,3))
        k <- rgb(n[1], n[2], n[3], max=255)
        return(k)
    }


#  get ROC AUC, adapted from https://stackoverflow.com/a/19071629
getROC_AUC <- 
    function(probs, true_Y)
    {
        labs <- sort(unique(na.omit(true_Y)))
        lab0 <- labs[1]
        lab1 <- labs[2]
        probsSort <- sort(probs, decreasing = TRUE, index.return = TRUE)
        val <- unlist(probsSort$x)
        idx <- unlist(probsSort$ix)  
        roc_y <- true_Y[idx];
        ny <- length(roc_y)
        fal_pr <- cumsum(roc_y %in% lab0)/sum(roc_y %in% lab0)
        tru_pr <- cumsum(roc_y %in% lab1)/sum(roc_y %in% lab1)    
        auc <- sum((fal_pr[2:ny]-fal_pr[1:(ny-1)])*tru_pr[2:ny])
        return(list(fal_pr=fal_pr, tru_pr=tru_pr, auc=auc))
    }


#==============================================================================
#   FIGURE HELPERS
#==============================================================================


#   custom horizontal axis
getax1 <-
    function(x, mylwd=gr^-2)
    {
        axis(1, axTicks(1), labels=rep('', length(axTicks(1))), lwd=0, lwd.ticks=mylwd, tck=-2e-2) 
        axis(1, lwd=0, line=-0.618)
    }


#   custom vertical axis
getax2 <- 
    function(x, mylwd=gr^-2)
    {
        axis(2, axTicks(2), labels=rep('', length(axTicks(2))), lwd=0, lwd.ticks=mylwd, tck=-2e-2) 
        axis(2, lwd=0, line=-0.618)
    }


#   custom box
getbox <-
    function(x, mylwd=gr^-2)
    {
        box(lwd=gr^+1, col='white')
        box(lwd=mylwd)
    }


#   title plot
titleplot <-
    function(x='whatever', y_)
    {
        plot.new()
        plot.window(xlim=c(-1,1), ylim=c(-1,1))
        tit <- strsplit(x, '\n')[[1]]
        sh <- strheight('M')*(1+gr^-2)
        for (j in 1:length(tit)) {
            text(0, y_-(j-1)*sh, tit[j], font=1, pos=1, xpd=T, offset=0)
        }
    }


#   rugs for effect plots
getrugs <-
    function(x, dat=b)
    {
        top <- dat[dat$aut_ep_incumbent_t1%in%1, x]
        bot <- dat[dat$aut_ep_incumbent_t1%in%0, x]
        rug(top, side=3, lwd=gr^-1, col=grey(0.5,0.7), ticksize=0.03, lend='butt')
        rug(bot, side=1, lwd=gr^-1, col=grey(0.5,0.7), ticksize=0.03, lend='butt')
    }


#   rugs for effect plots
getrugs2 <-
    function(x, ind, mk=natcol('red'), dat=b, label=F, lab='GOP\n2016')
    {
        ii <- 1:nrow(dat)
        top <- dat[(dat$aut_ep_incumbent_t1%in%1)&(ii%in%ind), x]
        bot <- dat[(dat$aut_ep_incumbent_t1%in%0)&(ii%in%ind), x]
        rug(top, side=3, lwd=gr^-0, col=mk, ticksize=0.03*gr^1, lend='butt')
        rug(bot, side=1, lwd=gr^-0, col=mk, ticksize=0.03*gr^1, lend='butt')
        if (label) {
            pu <- par('usr')
            yy <- pu[4]-0.03*gr - strheight('M', cex=gr^-1)
            if (length(top)>0) { text(top, yy, lab, col=mk, cex=gr^-1) }
        }
    }

#   SCRIPT END